home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / pas / swag / datetime.swg / 0036_Handy Date-Time Unit.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-09  |  16KB  |  504 lines
  1.  
  2.               (* * * * * * * * * * * * * * * * * * * * * * *)
  3.               (*   UNIT: DTIME - By Alan Graff, Nov. 92    *)
  4.               (*      Compiled from routines found in:     *)
  5.               (*       DATEPAK4: W.G.Madison, Nov. 87      *)
  6.               (*       UNIXDATE: Brian Stark, Jan. 92      *)
  7.               (*   Plus various things of my own creation  *)
  8.               (*   and extracted from Fidonet PASCAL echo  *)
  9.               (*   messages and other sources.             *)
  10.               (*      Contributed to the Public Domain     *)
  11.               (*          Version 1.1 - Nov. 1992          *)
  12.               (* * * * * * * * * * * * * * * * * * * * * * *)
  13.  
  14. UNIT DTime;
  15. {**************************************************************}
  16. INTERFACE
  17. uses crt,dos;
  18.  
  19. TYPE DATETYPE = record
  20.      day:WORD;
  21.      MONTH:WORD;
  22.      YEAR:WORD;
  23.      dow:word;
  24.      end;
  25.  
  26.  (* Sundry determinations of current date/time variables *)
  27. Function  DayOfYear:word;  (* Returns 1 to 365 *)
  28. Function DayOfMonth:word;  (* Returns 1 to 31  *)
  29. Function DayOfWeek:word;   (* Returns 1 to 7   *)
  30. Function MonthOfYear:word; (* Returns 1 to 12  *)
  31. Function ThisYear:word;    (* Returns current year *)
  32. Function ThisHour:word;    (* Returns 1 to 24  *)
  33. Function ThisMinute:word;  (* Returns 0 to 59  *)
  34.   (* Calculate what day of the week a particular date falls on *)
  35. Procedure WkDay(Year,Month,Day:Integer; var WeekDay:Integer);
  36.    (* Full Julian conversions *)
  37. Procedure GregorianToJulianDN(Year,Month,Day:Integer;var JulianDN:LongInt);
  38. Procedure JulianDNToGregorian(JulianDN:LongInt;var Year,Month,Day:Integer);
  39.    (* 365 day Julian conversions *)
  40. Procedure GregorianToJulianDate(Year,Month,Day:Integer;var JulianDate:Integer);
  41. Procedure JulianToGregorianDate(JulianDate,Year:Integer;var Month,Day:Integer);
  42.    (* Sundry string things *)
  43. Function  DateString:String;  (* Returns system date as "mm-dd-yy" string *)
  44. Function  TimeString:String;  (* Returns system time as "00:00:00" string *)
  45.   (* Create current YYMMDD string to use as a file name *)
  46. Function DateAFile(dy,dm,dd:word):string;
  47.   (* Return YY-MM-DD string from filename created by DateAFile func *)
  48. Function Parsefile(s:string):string;
  49.    (* Return values of 1 day ago *)
  50. Procedure Yesterday(Var y,m,d:integer);
  51.    (* Return values of 1 day ahead *)
  52. Procedure Tomorrow(Var y,m,d:integer);
  53.  (* Adjust time based on "TZ" environment *)
  54. Function  GetTimeZone : ShortInt;
  55. Function  IsLeapYear(Source : Word) : Boolean;  (* What it says :-)  *)
  56.   (* Unix date conversions *)
  57. Function Norm2Unix(Y,M,D,H,Min,S:Word):LongInt;
  58. Procedure Unix2Norm(Date:LongInt;Var Y,M,D,H,Min,S:Word);
  59.   (* Determines what day of year Easter falls on *)
  60. Procedure Easter(Year:Word;Var Date:DateType);
  61.   (* Determines what day of year Thanksgiving falls on *)
  62. Procedure Thanksgiving(Year:Word;Var Date:DateType);
  63.   (* Determine what percentage of moon is lit on a particular night *)
  64. Function MoonPhase(Date:Datetype):Real;
  65.  
  66. IMPLEMENTATION
  67.  
  68. const
  69.   D0 =    1461;
  70.   D1 =  146097;
  71.   D2 = 1721119;
  72.   DaysPerMonth :  Array[1..12] of ShortInt =
  73. (031,028,031,030,031,030,031,031,030,031,030,031);
  74.   DaysPerYear  :  Array[1..12] of Integer  =
  75. (031,059,090,120,151,181,212,243,273,304,334,365);
  76.   DaysPerLeapYear :    Array[1..12] of Integer  =
  77. (031,060,091,121,152,182,213,244,274,305,335,366);
  78.   SecsPerYear      : LongInt  = 31536000;
  79.   SecsPerLeapYear  : LongInt  = 31622400;
  80.   SecsPerDay       : LongInt  = 86400;
  81.   SecsPerHour      : Integer  = 3600;
  82.   SecsPerMinute    : ShortInt = 60;
  83.  
  84. Procedure GregorianToJulianDN;
  85. var
  86.   Century,
  87.   XYear    : LongInt;
  88. begin {GregorianToJulianDN}
  89.   If Month <= 2 then begin
  90.     Year := pred(Year);
  91.     Month := Month + 12;
  92.     end;
  93.   Month := Month - 3;
  94.   Century := Year div 100;
  95.   XYear := Year mod 100;
  96.   Century := (Century * D1) shr 2;
  97.   XYear := (XYear * D0) shr 2;
  98.   JulianDN := ((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century;
  99.   end; {GregorianToJulianDN}
  100. {**************************************************************}
  101. Procedure JulianDNToGregorian;
  102. var
  103.   Temp,
  104.   XYear   : LongInt;
  105.   YYear,
  106.   YMonth,
  107.   YDay    : Integer;
  108. begin {JulianDNToGregorian}
  109.   Temp := (((JulianDN - D2) shl 2) - 1);
  110.   XYear := (Temp mod D1) or 3;
  111.   JulianDN := Temp div D1;
  112.   YYear := (XYear div D0);
  113.   Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
  114.   YMonth := Temp div 153;
  115.   If YMonth >= 10 then begin
  116.     YYear := YYear + 1;
  117.     YMonth := YMonth - 12;
  118.     end;
  119.   YMonth := YMonth + 3;
  120.   YDay := Temp mod 153;
  121.   YDay := (YDay + 5) div 5;
  122.   Year := YYear + (JulianDN * 100);
  123.   Month := YMonth;
  124.   Day := YDay;
  125.   end; {JulianDNToGregorian}
  126. {**************************************************************}
  127. Procedure GregorianToJulianDate;
  128. var
  129.   Jan1,
  130.   Today : LongInt;
  131. begin {GregorianToJulianDate}
  132.   GregorianToJulianDN(Year, 1, 1, Jan1);
  133.   GregorianToJulianDN(Year, Month, Day, Today);
  134.   JulianDate := (Today - Jan1 + 1);
  135.   end; {GregorianToJulianDate}
  136. {**************************************************************}
  137. Procedure JulianToGregorianDate;
  138. var
  139.   Jan1  : LongInt;
  140. begin
  141.   GregorianToJulianDN(Year, 1, 1, Jan1);
  142.   JulianDNToGregorian((Jan1 + JulianDate - 1), Year, Month, Day);
  143.   end; {JulianToGregorianDate}
  144. {**************************************************************}
  145. Procedure WkDay;
  146. var
  147.   DayNum : LongInt;
  148. begin
  149.   GregorianToJulianDN(Year, Month, Day, DayNum);
  150.   DayNum := ((DayNum + 1) mod 7);
  151.   WeekDay := (DayNum) + 1;
  152.   end; {DayOfWeek}
  153. {**************************************************************}
  154. Procedure Yesterday(Var Y,M,D:integer);
  155. var jdn:longint;
  156. begin
  157. GregorianToJulianDN(Y,M,D,JDN);
  158. JDN:=JDN-1;
  159. JulianDNToGregorian(JDN,Y,M,D);
  160. end;
  161. {**************************************************************}
  162. Procedure Tomorrow(Var Y,M,D:integer);
  163. var JDN:longint;
  164. begin
  165. GregorianToJulianDN(Y,M,D,JDN);
  166. JDN:=JDN+1;
  167. JulianDNToGregorian(JDN,Y,M,D);
  168. end;
  169. {**************************************************************}
  170. Function TimeString:string;
  171. var hr,mn,sec,hun:word;
  172. s,q:string;
  173. begin
  174.   q:='';
  175.   gettime(hr,mn,sec,hun);
  176.   if hr<10 then q:=q+'0';
  177.   str(hr:1,s);
  178.   q:=q+s+':';
  179.   if mn<10 then q:=q+'0';
  180.   str(mn:1,s);
  181.   q:=q+s;
  182.   TimeString:=q;
  183. end;
  184. {**************************************************************}
  185. Function ThisHour:Word;
  186. var hr,mn,sec,hun:word;
  187. begin
  188.   gettime(hr,mn,sec,hun);
  189.   ThisHour:=hr;
  190. end;
  191. {**************************************************************}
  192. Function ThisMinute:Word;
  193. var hr,mn,sec,hun:word;
  194. begin
  195.   gettime(hr,mn,sec,hun);
  196.   ThisMinute:=mn;
  197. end;
  198. {**************************************************************}
  199. Function DateString:string;
  200. var yr,mo,dy,dow:word;
  201.     s,q:string;
  202. begin
  203.   q:='';
  204.   getdate(yr,mo,dy,dow);
  205.   if mo<10 then q:=q+'0';
  206.   str(mo:1,s);
  207.   q:=q+s+'-';
  208.   if dy<10 then q:=q+'0';
  209.   str(dy:1,s);
  210.   q:=q+s+'-';
  211.   while yr>100 do yr:=yr-100;
  212.   if yr<10 then q:=q+'0';
  213.   str(yr:1,s);
  214.   q:=q+s;
  215.   Datestring:=q;
  216. end;
  217. {**************************************************************}
  218. Function parsefile(s:string):string;  { Return date string from a file name }
  219. var mo,errcode:word;                  { in either YYMMDD.EXT or MMDDYY.EXT  }
  220.     st:string;                        { format.                             }
  221. begin
  222. st:=copy(s,1,2)+'-'+copy(s,3,2)+'-'+copy(s,5,2);
  223. parsefile:=st;
  224. end;
  225. {**************************************************************}
  226. function dateafile(dy,dm,dd:word):string;
  227. var s1,s2:string;
  228. begin
  229. while dy>100 do dy:=dy-100;
  230. str(dy,s1);
  231. while length(s1)<2 do s1:='0'+s1;
  232. s2:=s1;
  233. str(dm,s1);
  234. while length(s1)<2 do s1:='0'+s1;
  235. s2:=s2+s1;
  236. str(dd,s1);
  237. while length(s1)<2 do s1:='0'+s1;
  238. s2:=s2+s1;
  239. dateafile:=s2;
  240. end;
  241. {**************************************************************}
  242. Function DayOfMonth:Word;
  243. var yr,mo,dy,dow:word;
  244. begin
  245.   getdate(yr,mo,dy,dow);
  246.   DayOfMonth:=dy;
  247. end;
  248. {**************************************************************}
  249. Function ThisYear:Word;
  250. var yr,mo,dy,dow:word;
  251. begin
  252.   getdate(yr,mo,dy,dow);
  253.   ThisYear:=yr;
  254. end;
  255.  
  256. {**************************************************************}
  257. Function DayOfWeek:word;
  258. var yr,mo,dy,dow:word;
  259. begin
  260.   getdate(yr,mo,dy,dow);    (* Turbo Pascal authors never saw a *)
  261.   dow:=dow+1;               (* calendar.  Their first day of    *)
  262.   if dow=8 then dow:=1;     (* week is Monday....               *)
  263.   DayOfWeek:=dow;
  264. end;
  265. {**************************************************************}
  266. Function MonthOfYear:Word;
  267. var yr,mo,dy,dow:word;
  268. begin
  269.   getdate(yr,mo,dy,dow);
  270.   monthofyear:=mo;
  271. end;
  272. {**************************************************************}
  273. Function GetTimeZone : ShortInt;
  274. Var
  275.   Environment : String;
  276.   Index : Integer;
  277. Begin
  278.   GetTimeZone := 0;                            {Assume UTC}
  279.   Environment := GetEnv('TZ');       {Grab TZ string}
  280.   For Index := 1 To Length(Environment) Do
  281.     Environment[Index] := Upcase(Environment[Index]);
  282.   If Environment =  'EST05'    Then GetTimeZone := -05; {USA EASTERN}
  283.   If Environment =  'EST05EDT' Then GetTimeZone := -06;
  284.   If Environment =  'CST06'    Then GetTimeZone := -06; {USA CENTRAL}
  285.   If Environment =  'CST06CDT' Then GetTimeZone := -07;
  286.   If Environment =  'MST07'    Then GetTimeZone := -07; {USA MOUNTAIN}
  287.   If Environment =  'MST07MDT' Then GetTimeZone := -08;
  288.   If Environment =  'PST08'    Then GetTimeZone := -08;
  289.   If Environment =  'PST08PDT' Then GetTimeZone := -09;
  290.   If Environment =  'YST09'    Then GetTimeZone := -09;
  291.   If Environment =  'AST10'    Then GetTimeZone := -10;
  292.   If Environment =  'BST11'    Then GetTimeZone := -11;
  293.   If Environment =  'CET-1'    Then GetTimeZone :=  01;
  294.   If Environment =  'CET-01'   Then GetTimeZone :=  01;
  295.   If Environment =  'EST-10'   Then GetTimeZone :=  10;
  296.   If Environment =  'WST-8'    Then GetTimeZone :=  08; {Perth,W.Austrailia}
  297.   If Environment =  'WST-08'   Then GetTimeZone :=  08;
  298. End;
  299. {**************************************************************}
  300. Function IsLeapYear(Source : Word) : Boolean;
  301. Begin
  302.   If (Source Mod 4 = 0) Then
  303.     IsLeapYear := True
  304.   Else
  305.     IsLeapYear := False;
  306. End;
  307. {**************************************************************}
  308. Function Norm2Unix(Y,M,D,H,Min,S : Word) : LongInt;
  309. Var
  310.   UnixDate : LongInt;
  311.   Index    : Word;
  312. Begin
  313.   UnixDate := 0;                                              {initialize}
  314.   Inc(UnixDate,S);                                           {add seconds}
  315.   Inc(UnixDate,(SecsPerMinute * Min));                       {add minutes}
  316.   Inc(UnixDate,(SecsPerHour * H));                             {add hours}
  317.   UnixDate := UnixDate - (GetTimeZone * SecsPerHour);         {UTC offset}
  318.   If D > 1 Then                              {has one day already passed?}
  319.     Inc(UnixDate,(SecsPerDay * (D-1)));
  320.   If IsLeapYear(Y) Then
  321.     DaysPerMonth[02] := 29
  322.   Else
  323.     DaysPerMonth[02] := 28;                          {Check for Feb. 29th}
  324.   Index := 1;
  325.   If M > 1 Then For Index := 1 To (M-1) Do {has one month already passed?}
  326.     Inc(UnixDate,(DaysPerMonth[Index] * SecsPerDay));
  327.   While Y > 1970 Do
  328.   Begin
  329.     If IsLeapYear((Y-1)) Then
  330.       Inc(UnixDate,SecsPerLeapYear)
  331.     Else
  332.       Inc(UnixDate,SecsPerYear);
  333.     Dec(Y,1);
  334.   End;
  335.   Norm2Unix := UnixDate;
  336. End; Procedure Unix2Norm(Date : LongInt; Var Y, M, D, H, Min, S : Word);
  337. {}
  338. Var
  339.   LocalDate : LongInt; Done : Boolean; X : ShortInt; TotDays : Integer;
  340. Begin
  341.   Y   := 1970; M := 1; D := 1; H := 0; Min := 0; S := 0;
  342.   LocalDate := Date + (GetTimeZone * SecsPerHour);      {Local time date}
  343.   Done := False;
  344.   While Not Done Do
  345.   Begin
  346.     If LocalDate >= SecsPerYear Then
  347.     Begin
  348.       Inc(Y,1);
  349.       Dec(LocalDate,SecsPerYear);
  350.     End
  351.     Else
  352.       Done := True;
  353.     If (IsLeapYear(Y+1)) And (LocalDate >= SecsPerLeapYear) And
  354.        (Not Done) Then
  355.     Begin
  356.       Inc(Y,1);
  357.       Dec(LocalDate,SecsPerLeapYear);
  358.     End;
  359.   End;
  360.   M := 1; D := 1;
  361.   Done := False;
  362.   TotDays := LocalDate Div SecsPerDay;
  363.   If IsLeapYear(Y) Then
  364.   Begin
  365.     DaysPerMonth[02] := 29;
  366.     X := 1;
  367.     Repeat
  368.       If (TotDays <= DaysPerLeapYear[x]) Then
  369.       Begin
  370.         M := X;
  371.         Done := True;
  372.         Dec(LocalDate,(TotDays * SecsPerDay));
  373.         D := DaysPerMonth[M]-(DaysPerLeapYear[M]-TotDays) + 1;
  374.       End
  375.       Else
  376.         Done := False;
  377.       Inc(X);
  378.     Until (Done) or (X > 12);
  379.   End
  380.   Else
  381.   Begin
  382.     DaysPerMonth[02] := 28;
  383.     X := 1;
  384.     Repeat
  385.       If (TotDays <= DaysPerYear[x]) Then
  386.       Begin
  387.         M := X;
  388.         Done := True;
  389.         Dec(LocalDate,(TotDays * SecsPerDay));
  390.         D := DaysPerMonth[M]-(DaysPerYear[M]-TotDays) + 1;
  391.       End
  392.       Else
  393.         Done := False;
  394.       Inc(X);
  395.     Until Done = True or (X > 12);
  396.   End;
  397.   H := LocalDate Div SecsPerHour;
  398.     Dec(LocalDate,(H * SecsPerHour));
  399.   Min := LocalDate Div SecsPerMinute;
  400.     Dec(LocalDate,(Min * SecsPerMinute));
  401.   S := LocalDate;
  402. End;
  403. {**************************************************************}
  404. Function DayOfYear;
  405. var
  406.   HCentury,Century,Xyear,
  407.   Ripoff,HXYear    : LongInt;
  408.   Holdyear,Holdmonth,Holdday:Integer;
  409.   year,month,day,dofwk:word;
  410. begin {DayofYear}
  411.   getdate(year,month,day,dofwk);
  412.   Holdyear:=year-1;
  413.   Holdmonth:=9;
  414.   Holdday:=31;
  415.   HCentury := HoldYear div 100;
  416.   HXYear := HoldYear mod 100;
  417.   HCentury := (HCentury * D1) shr 2;
  418.   HXYear := (HXYear * D0) shr 2;
  419.   Ripoff := ((((HoldMonth * 153) + 2) div 5) + HoldDay) + D2 + HXYear +
  420. HCentury;
  421.   If Month <= 2 then begin
  422.     Year := pred(Year);
  423.     Month := Month + 12;
  424.     end;
  425.   Month := Month - 3;
  426.   Century := Year div 100;
  427.   XYear := Year mod 100;
  428.   Century := (Century * D1) shr 2;
  429.   XYear := (XYear * D0) shr 2;
  430.   DayofYear := (((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century)-
  431. ripoff;
  432.   end; {DayOfYear}
  433. Procedure Easter(Year : Word; Var Date : DateType);
  434.    (* Calculates what day Easter falls on in a given year         *)
  435.    (* Set desired Year and result is returned in Date variable    *)
  436. Var
  437.    GoldenNo,
  438.    Sun,
  439.    Century,
  440.    LeapCent,
  441.    LunarCorr,
  442.    Epact,
  443.    FullMoon : Integer;
  444. Begin
  445.    Date.Year := Year;
  446.    GoldenNo := (Year Mod 19) + 1;
  447.    Century := (Year Div 100) + 1;
  448.    LeapCent := (3 * Century Div 4) - 12;
  449.    LunarCorr := ((8 * Century + 5) Div 25) - 5;
  450.    Sun := (5 * Year Div 4) - LeapCent - 10;
  451.    Epact := Abs(11 * GoldenNo + 20 + LunarCorr - LeapCent) Mod 30;
  452.    If ((Epact = 25) And (GoldenNo > 11)) Or (Epact = 24) then
  453.       Inc(Epact);
  454.    FullMoon := 44 - Epact;
  455.    If FullMoon < 21 then
  456.       Inc(FullMoon, 30);
  457.    Date.Day := FullMoon + 7 - ((Sun + FullMoon) Mod 7);
  458.    If Date.Day > 31 then
  459.       Begin
  460.          Dec(Date.Day, 31);
  461.          Date.Month := 4;
  462.       End
  463.    Else
  464.       Date.Month := 3;
  465.    Date.DOW := 0;
  466. End;
  467. {**************************************************************}
  468. Procedure Thanksgiving(Year : Word; Var Date : DateType);
  469.    (* Calculates what day Thanksgiving falls on in a given year   *)
  470.    (* Set desired Year and result is returned in Date variable    *)
  471. Var
  472.   Counter,WeekDay:Word;
  473.   Daynum:longint;
  474. Begin
  475.    Date.Year := Year;
  476.    Date.Month := 11;
  477.    counter:=29;
  478.    repeat
  479.      dec(counter);
  480.      GregorianToJulianDN(Date.Year, Date.Month, Counter, DayNum);
  481.      DayNum := ((DayNum + 1) mod 7);
  482.      WeekDay := (DayNum) + 1;
  483.    Until Weekday = 5;
  484.    Date.Day:=Counter;
  485. End;
  486. {*************************************************************}
  487. Function MoonPhase(Date:Datetype):Real;
  488.   (* Determines APPROXIMATE phase of the moon (percentage lit)   *)
  489.   (* 0.00 = New moon, 1.00 = Full moon                           *)
  490.   (* Due to rounding, full values may possibly never be reached  *)
  491.   (* Valid from Oct. 15, 1582 to Feb. 28, 4000                   *)
  492.   (* Calculations adapted to Turbo Pascal from routines found in *)
  493.   (* "119 Practical Programs For The TRS-80 Pocket Computer"     *)
  494.   (* John Clark Craig, TAB Books, 1982                      (Ag) *)
  495. VAR j:longint; m:real;
  496. Begin
  497.   GregorianToJulianDN(Date.Year,Date.Month,Date.Day,J);
  498.   M:=(J+4.867)/ 29.53058;
  499.   M:=2*(M-Int(m))-1;
  500.   MoonPhase:=Abs(M);
  501. end;
  502.  
  503. END.
  504.